;; Usage: run with `guile -s' and the only argument being the instance domain/URL.
;; Example: `guile -s nodeinfo.scm be.cutewith.me'
(use-modules (json)
             (ice-9 format)
             (ice-9 match)
             (ice-9 iconv)
             (srfi srfi-1)
             (srfi srfi-11)
             (rnrs bytevectors)
             (web uri)
             (web response)
             (web client))

;; Obtaining nodeinfo

(define (string->uri-https s)
  "Try parsing the string S as an URI. If no scheme is present in the
string, assume 'https. The path should be empty."
  (let* ((base (string->uri-reference s))
         (scheme (or (uri-scheme base) 'https))
         (host (or (uri-host base) (uri-path base))))
    (build-uri scheme
               #:userinfo (uri-userinfo base)
               #:host host
               #:port (uri-port base)
               #:validate? #t
               #:path ""
               #:query (uri-query base))))


(define (nodeinfo-url instance)
  "Construct an URL to INSTANCE/.well-known/nodeinfo."
  (let* ((base (string->uri-https instance)))
    (build-uri (uri-scheme base)
               #:userinfo (uri-userinfo base)
               #:host (uri-host base)
               #:port (uri-port base)
               #:validate? #t
               #:path "/.well-known/nodeinfo")))

(define (get-json-scm uri)
  "Perform a GET request for the URI, parse the response as json and
return a corresponding alist."
  (let-values (((res body)
                (http-get uri
                          #:body #f
                          #:version '(1 . 1)
                          #:keep-alive? #f
                          #:decode-body? #t
                          #:streaming? #f)))
    (match (response-code res)
      (200
       (json-string->scm (bytevector->string body "utf-8")))
      (_
       ;; Error
       (throw 'nodeinfo `((request . ,uri)
                          (response-code . ,(response-code res))
                          (response-phrase . ,(response-reason-phrase res))
                          (response .
                           ,(if (bytevector? body)
                               (bytevector->string body "utf-8")
                               body))))))))

(define (-> data . args)
  "Deep accessor for association lists. Example (-> lst 'key1 'key2
'key3)."
  (define (f field acc)
    (cond
     ((number? field)
      (vector-ref acc field))
     (else (assoc-ref acc field))))
  (fold f data args))


(define (get-nodeinfo-json-url instance)
  "Get the URI for the nodeinfo .json file associated with the
instance."
  (let* ((uri (nodeinfo-url instance))
         (data (get-json-scm uri))
         (links (-> data "links")))
    (string->uri (assoc-ref (vector-ref links 0) "href"))))

(define (get-nodeinfo instance)
  (let* ((uri (get-nodeinfo-json-url instance))
         (data (get-json-scm uri))
         (metadata (-> data "metadata"))         
         (users (-> data "usage" "users" "total"))
         (posts (-> data "usage" "localPosts"))
         (open-registrations (-> data "openRegistrations"))
         (name (-> metadata "nodeName"))
         (software (-> data "software" "name"))
         (version (-> data "software" "version"))
         (features (vector->list (-> metadata "features")))
         (formats (vector->list (-> metadata "postFormats")))
         (mrf-simple (-> metadata "federation" "mrf_simple"))
         (mrf-accept (vector->list (-> mrf-simple "accept")))
         (mrf-nsfw (vector->list (-> mrf-simple "media_nsfw")))
         (mrf-media-remove (vector->list (-> mrf-simple "media_removal")))
         (mrf-reject (vector->list (-> mrf-simple "reject")))
         (mrf-remove (vector->list (-> mrf-simple "federated_timeline_removal")))
         (format-mrf-list (lambda (type l)
                            (format #t "~:{~3t~a: ~38t~a\n~}"
                                    (map (lambda (x) (list x type)) l)))))
    (format #t "Node: ~a (~a)\n" name instance)
    (format #t "~d user~:p \t ~d post~:p\n" users posts)
    (format #t "Registrations are ~:[closed~;open~]\n" open-registrations)
    (format #t "Running ~a ~@[~a~]\n" software version)
    (format #t "Features:\n~{~3t - ~a\n~}" features)
    (format #t "Enabled formats: ~a\n" formats)
    (format #t "MRF (simple) policies:\n")
    (format-mrf-list "accept" mrf-accept)
    (format-mrf-list "auto-tag NSFW" mrf-nsfw)
    (format-mrf-list "remove all media" mrf-media-remove)
    (format-mrf-list "remove from TWKN" mrf-remove)  
    (format-mrf-list "reject" mrf-reject)))

(unless (= (length (command-line)) 2)
    (begin
      (format (current-error-port) "Usage: guile -s ~a <INSTANCE>\n" (car (command-line)))
      (exit)))

(get-nodeinfo (cadr (command-line)))
